home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / environment.t < prev    next >
Text File  |  1988-02-05  |  12KB  |  296 lines
  1. (herald environment
  2.   (env tsys (osys weak) (osys table)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;;; code for value cells, environments, locales, and loaded-files.
  28.  
  29. ;;; general remarks:
  30. ;;; - a locale is a kind of environment.
  31. ;;; - a loaded-file is a different kind of environment.
  32. ;;; - the interpreter creates other environments which are neither
  33. ;;;   loaded-files nor locales.
  34. ;;; - every locale maintains a population of its inferior loaded-files.
  35. ;;; - any environment may be used as a "shape" (see eval).
  36. ;;; - "id" usually abbreviates "loaded-file identifier."
  37.           
  38. (define-operation (locale-inferiors obj))
  39. (define-operation (locale-walk obj proc))
  40. (define-predicate locale?)
  41.  
  42. (define-operation (loaded-files env)
  43.   (if (environment? env) 
  44.       (loaded-files (env-superior env))
  45.       (error "loaded files not found ~s" env)))
  46.  
  47. (define-settable-operation (loaded-file env id))
  48.  
  49. (define set-loaded-file (setter loaded-file))
  50.  
  51. (define-operation (env-syntax-table env) 
  52.   (if (environment? env) 
  53.       (env-syntax-table (env-superior env))
  54.       (error "env-syntax-table not found ~s" env)))
  55.  
  56. (define-simple-switch print-env-warnings?
  57.                       boolean?
  58.                       t)
  59.  
  60. (define (env-warning msg id)
  61.   (cond ((print-env-warnings?)
  62.          (let ((out (error-output)))
  63.            (format out "[~a~_~s]~_" msg id)
  64.            (force-output out)))))
  65.  
  66. (define (check-rebinding vc dfining? who)
  67.   (ignore who)
  68.   (cond ((nonvalue? (vcell-contents vc))
  69.          nil)   ; do nothing
  70.         ((vcell-defined? vc)
  71.          (env-warning (if dfining? "Redefining" "Assigning")
  72.                       (vcell-id vc)))
  73.         (dfining? 
  74.          (env-warning "Defining" (vcell-id vc))))
  75.   (if dfining? 
  76.       (set-vcell-defined vc)
  77.       (set-vcell-undefined vc))
  78.   vc)
  79.  
  80. ;;; non-local reference.
  81.  
  82. (define *value
  83.   (object (lambda (env id)
  84.             (cond ((env-lookup env id nil nil) => contents)
  85.                   (else
  86.                    (error "unbound variable~%  (~s ~s ~s)"
  87.                           '*value env id))))
  88.           ((setter self) *set-value)))
  89.  
  90. ;;; non-local definition.
  91.  
  92. (define (*define env id val)
  93.   (let ((vcell (env-lookup env id t t)))
  94.     (distribute-vcells vcell)
  95.     (define-contents vcell val)
  96.     (set-identification val id)
  97.     val))
  98.  
  99. (define (*lset env id val)
  100.   (let ((vcell (env-lookup env id t t)))
  101.     (distribute-vcells vcell)
  102.     (set-contents vcell val)
  103.     val))
  104.  
  105. (define (*set-value env id val)
  106.   (set-contents (reluctantly-bind env id) val)
  107.   val)
  108.  
  109. (define (reluctantly-bind env id)
  110.   (cond ((env-lookup env id nil nil))
  111.     (else
  112.      (env-warning "Binding" id)
  113.      (let ((vcell (env-lookup env id t t)))
  114.        (distribute-vcells vcell)
  115.        vcell))))
  116.         
  117.  
  118. (define (*bound? env id)                ; ugh
  119.   (cond ((env-lookup env id nil nil)
  120.          => (lambda (vc)
  121.               (or (not (vcell? vc))
  122.                   (not (nonvalue? (vcell-contents vc))))))
  123.         (else nil)))
  124.  
  125. ;;; env-lookup is defined by open.t to be effectively the same as call.
  126.  
  127. (define-operation (env-superior env))
  128. (define-predicate environment?)
  129. (define-operation (virtual-vcell-table env))
  130.  
  131. ;;; super is any environment, not necessarily a locale.
  132.  
  133. (define (make-locale super . maybe-id)
  134.   (really-make-locale super
  135.                       (if (null? maybe-id) nil (car maybe-id))
  136.                       nil))
  137.                                                 
  138. (define (make-inferior-locale superior name)
  139.   (let ((inferior-env (make-locale superior name)))
  140.     (*define superior name inferior-env)
  141.     inferior-env))
  142.  
  143.  
  144. (define (make-locale-table id boot-table)
  145.   (let ((symbol-table   (if boot-table boot-table (make-symbol-table id)))
  146.         (other-id-table (make-table id)))
  147.     (object (lambda (id)
  148.               (if (symbol? id)
  149.                   (table-entry symbol-table id)
  150.                   (table-entry other-id-table id)))
  151.       ((setter self)
  152.        (lambda (id val)
  153.          (if (symbol? id)
  154.              (set (table-entry symbol-table id) val)
  155.              (set (table-entry other-id-table id) val))))
  156.       ((locale-walk self proc)
  157.        (table-walk symbol-table proc)
  158.        (table-walk other-id-table proc)))))
  159.  
  160. ;;; Syntax table below should be a delay, but delay isn't
  161. ;;; available in the VM.
  162.  
  163. (define (really-make-locale super id boot-table)
  164.   (let ((locale-table       (make-locale-table id boot-table))
  165.         (syntax-table       '#f)
  166.         (loaded-files-table (make-string-table 'loaded-files))
  167.         (lpop               '#f)
  168.         (virtual-vcells     (make-table `(virtual-vcells ,id))))
  169.     (labels
  170.      ((env (object
  171.              (lambda (id local? create?)
  172.                (cond ((locale-table id))
  173.                      (local?
  174.                       (cond (create?                                     
  175.                              (let ((new (make-vcell id)))
  176.                                (fix-virtual-vcells env new)
  177.                                (cond ((and super (super id nil nil))
  178.                                       => (lambda (vcell)
  179.                                            (env-warning "Shadowing" id)
  180.                                            (fix-location-lists env vcell new)
  181.                        (update-vcell-header-byte vcell))))
  182.                                (set (locale-table id) new)
  183.                    (update-vcell-header-byte new)
  184.                                new))       
  185.                             (else nil)))
  186.                      ((and super (super id nil nil)))
  187.                      (create?                         
  188.                       (cond ((table-entry virtual-vcells id))
  189.                             (else
  190.                              (let ((vcell (make-vcell id)))
  191.                                (set (table-entry virtual-vcells id) vcell)
  192.                                vcell))))
  193.                      (else nil)))
  194.              ((env-superior self) super)
  195.              ((env-syntax-table self)
  196.               (cond (syntax-table)
  197.                     (else
  198.                      (set syntax-table 
  199.                           (make-syntax-table
  200.                            (if super (env-syntax-table super) nil)
  201.                             id))
  202.                      (set (env-for-syntax-definition syntax-table) env)
  203.                      syntax-table)))
  204.              ((loaded-files self) loaded-files-table)
  205.              ((loaded-file self id)
  206.               (let ((unit (table-entry loaded-files-table id)))
  207.                 (cond (unit => identity)
  208.                       (else
  209.                        (let ((superior (env-superior self)))
  210.                          (if superior (loaded-file superior id) '#f))))))
  211.              ((set-loaded-file self id unit)
  212.               ;++ we should be saving the file write date and checking it.
  213.               (set (table-entry loaded-files-table id) unit))
  214.              ((virtual-vcell-table self) virtual-vcells)
  215.              ((locale-inferiors self)
  216.               (if (null? lpop)
  217.                   (set lpop (make-population `(locale-inferiors ,self))))
  218.               lpop)
  219.              ((locale-walk self proc)
  220.               (locale-walk locale-table proc))
  221.              ((locale? self) t)
  222.              ((print-info self) id)
  223.              ((set-identification self val) (if (not id) (set id val)))
  224.              ((get-environment self) self)
  225.              ((get-loaded-file self)
  226.               (get-loaded-file (env-superior self)))
  227.              ((environment? self) t)
  228.              ((print-type-string self) "Locale"))))
  229.       (if super
  230.           (add-to-population (locale-inferiors (env-locale super)) env)
  231.           (add-to-population top-level-environments env))
  232. ;++ this seems pretty random
  233.       (cond ((symbol? id)
  234.              (let ((vcell (make-vcell id)))
  235.                (set (vcell-contents vcell) env)
  236.                (set (locale-table id) vcell))))
  237.       env)))
  238.  
  239. (define (update-vcell-header-byte vcell)
  240.   (if (fx= (vector-length (weak-alist-elements (vcell-locations vcell))) 0)
  241.       (set (mref-8-u vcell -2) 0)
  242.       (set (mref-8-u vcell -2) -1)))
  243.  
  244. (define (distribute-vcells vcell)
  245.   (let ((alist (vcell-vcell-locations vcell)))
  246.     (let* ((vec (weak-alist-elements alist))
  247.        (len (vector-length vec)))
  248.       (do ((i 0 (fx+ i 2)))
  249.       ((fx>= i len))
  250.     (set (extend-elt (vref vec i) (vref vec (fx+ i 1))) vcell)))))
  251.  
  252. ;;; Move ENV units from OLD-VCELL to NEW-VCELL if the variable is not
  253. ;;; bound in ENV.
  254.  
  255. (define (fix-location-lists env old-vcell new-vcell)
  256.   (cond ((not (env-lookup env (vcell-id old-vcell) t nil))
  257.          (weak-alist-move (vcell-locations old-vcell)
  258.                           (vcell-locations new-vcell)
  259.                           (lambda (unit)
  260.                             (eq? env (unit-env unit))))
  261.          (weak-alist-move (vcell-vcell-locations old-vcell)
  262.                           (vcell-vcell-locations new-vcell)
  263.                           (lambda (unit)
  264.                             (eq? env (unit-env unit))))
  265.          (walk-population (locale-inferiors env)
  266.                           (lambda (env)
  267.                             (fix-location-lists env old-vcell new-vcell))))))
  268.  
  269.  
  270. ;;; If ENV does not bind the variable and has a virtual-vcell for it the
  271. ;;; virtual-vcell's locations are added to VCELL's.
  272.  
  273. (define (fix-virtual-vcells env vcell)
  274.   (cond ((not (env-lookup env (vcell-id vcell) nil nil))
  275.          (let ((table (virtual-vcell-table env)))
  276.            (cond ((table-entry table (vcell-id vcell))
  277.                   => (lambda (v)
  278.                        (weak-alist-merge (vcell-locations v)
  279.                                          (vcell-locations vcell))
  280.                        (weak-alist-merge (vcell-vcell-locations v)
  281.                                          (vcell-vcell-locations vcell))
  282.                        (set (table-entry table (vcell-id vcell)) nil)))))
  283.          (walk-population (locale-inferiors env)
  284.                           (lambda (env)
  285.                             (fix-virtual-vcells env vcell))))))
  286.               
  287. (define top-level-environments
  288.         (make-population 'top-level-environments))
  289.  
  290. (define (env-locale env)
  291.   (do ((e env (env-superior e)))
  292.       ((locale? e) e)))
  293.  
  294. (define (make-empty-locale . maybe-id)
  295.   (make-locale nil (if (null? maybe-id) nil (car maybe-id))))
  296.